perm filename PAR.NEW[1,JRA]1 blob
sn#015595 filedate 1972-12-04 generic text, type T, neo UTF8
00100
00200
00300 (DEFPROP PARMOD1
00400 (LAMBDA(C D)
00500 (PROG (YC YD Z Z1 Z2 X Y Y1 Y2 PAR TS)
00700 (SETQ YC (CDR C))
00800 PAR1 (SETQ YD (CDR D))
01600 (SETQ X (CAR YC))
01700 (COND ((NEG X) (RETURN PAR))
01800 ((ORDERP (CAR X) EQUAL) (GO PAR2))
01900 ((NOT (EQ (CAR X) EQUAL)) (RETURN PAR)))
02000 PAR3 PAR3A
02100 (COND ((NEG (CAR YD)) (SETQ Z2 (CDAR YD))) (T (SETQ Z2 (CAR YD))))
02200 (SETQ Y1 (CDDR X))
02300 (SETQ Y2 (CADR X))
02400 PAR3B(COND ((VAR (CAR Y1)) (GO PAR7A)))
02450
02500 (SETQ Z (TERMS (CAAR Y1) (CDR Z2) PDEPTH))
02600 (COND ((NULL Z) (GO PAR7A)))
02700 PAR5 (SETQ Z1 Z)
02800 PAR4
02850 (COND
02862 ((CONST(CAR Y1))(COND((OR(VAR(CAAR Z1))(NOT(EQ(CAAR Y1)(CAAAR Z1))))
02868 (GO PAR7))(T(SETQ TS (COPY Y2))(GO PAR9))))
02871 ((OR(VAR(CAAR Z1))(NOT(EQ(CAAR Y1)(CAAAR Z1))))(GO PAR7)) )
02875 (SETQ Y(UNIFY(CDAR Y1)(CDAAR Z1)))
02900 (COND (Y(SETQ Y(CDR Y)) (GO PAR6)))
03000 PAR7 (SETQ Z1 (CDR Z1))
03100 (COND (Z1 (GO PAR4)))
03200 PAR7A
03275
03300 PAR7B (SETQ YD (CDR YD))
03400 (COND (YD (GO PAR3A)))
03500 PAR2 (SETQ YC (CDR YC))
03600 (COND (YC (GO PAR1)))
03700 (RETURN PAR)
03800 PAR6 (SETQ TS (CADR (SUBS3T* Y (LIST NIL Y2))))
03900 PAR9 (SETQ PARRES (SUBS3TA Y Z2 (CAR Z1) TS))
04000 (COND ((NEG (CAR YD)) (SETQ PARRES (CONS ESCAPE PARRES))))
04100 (SETQ Y (UNION Y C D X (CAR YD)))
04200 (COND ((NULL Y) (GO PAR7)))
04500 (SETQ PAR(CONS(SET2(CAR Y)TBL)PAR))
04600 (GO PAR7)))
04700 EXPR)
04800
04900 (DEFPROP PUNIFY
05000 (LAMBDA(X Y)
05100 (PROG (LC Z1 Z2 Z3 Z4 Z6 Z7)
05200 (SETQ LC (LIST NIL))
05300 U3 (SETQ Z1 (CAR X))
05400 (SETQ Z2 (CAR Y))
05500 (COND ((VAR Z1) (SETQ Z3 (SEARCH Z1 (CDR LC)))) (T (SETQ Z3 Z1)))
05600 (COND ((VAR Z2) (SETQ Z4 (SEARCH Z2 (CDR LC)))) (T (SETQ Z4 Z2)))
05700 (COND ((VAR Z3)
05800 (COND ((VAR Z4) (GO UN1))
05900 ((CONST Z4) (GO UN3))
06000 (T (COND ((NULL (CDR LC)) (RPLACD LC (LIST (CONS Z3 (COPY Z4)))) (GO UN2))
06100 ((NOT (VAR Z2)) (SETQ Z4 (SUBS3T* (CDR LC) Z4))))
06200 (COND ((OCCUR Z3 (CDR Z4)) (RETURN NIL)) (T (GO UN3))))))
06300 ((VAR Z4)(RETURN NIL))
06800 ((AND (CONST Z3) (CONST Z4)) (COND ((NOT (EQ (CAR Z3) (CAR Z4))) (RETURN NIL)) (T (GO UN2))))
06900 ((EQ (CAR Z3) (CAR Z4)) (SETQ Z6 (CDR (SUBS3T* (CDR LC) Z3)))
07000 (SETQ Z7 (CDR (SUBS3T* (CDR LC) Z4)))
07100 (SETQ X (APPEND Z6 (CDR X)))
07200 (SETQ Y (APPEND Z7 (CDR Y)))
07300 (GO U3))
07400 (T (RETURN NIL)))
07500 UN1 (SUBS2T Z3 Z4 LC)
07600 UN2 (SETQ X (CDR X))
07700 (COND (X (SETQ Y (CDR Y)) (GO U3)))
07800 (RETURN LC)
07900 UN3 (SUBS2T Z4 Z3 LC)
08000 (GO UN2)))
08100 EXPR)